\ NewFloatMgr 05.2.27 NAB
\ original 01.4.27 JCF

needs core-ext
needs sfdf
needs fsfdf  \ provides df! df@

module NewFloatMgr

: 2>r2>r
DUP (2>r) (2>r) DROP ; inline
: 2>r4>r
DUP (2>r) (4>r) DROP ; inline
: 4>r4>r
DUP (4>r) (4>r) DROP ; inline

CREATE atof-buf 32 CHARS ALLOT
DFVARIABLE dfresult
2VARIABLE rp-save

: r[
    [ (hex) 2B4F cs, \ mv.l rp,?(ds)
    rp-save cs, ]
; inline

: ]r
    [ (hex) 2E6D cs, \ mv.l ?(ds),rp
    rp-save cs, ]
; inline

: @dfresult ( -- df )
  [ dfresult 2 cells + ] literal 2@
  dfresult 2@
; inline

HERE BASE @ HEX \ in data space:
291F , \ move.l (rp)+,-(sp)
3B47 , OVER 8 + , \ move.w tos,?(ds)
4E4F , 0 , \ trap 15 ?
2F1C , \ move.l (sp)+,-(rp)
3E1C , \ DROP
4E75 , \ rts
20 allot BASE !
: baretrap
[ (hex) 4EAD cs, SWAP cs, ] ; inline

: (traplistbuilder) \ v trp
SWAP DUP >R 1+ SWAP R> OVER
\ v+1 trp v trp
( [ ' : COMPILE, ] ) : ROT ROT
\ v+1 trp csys v trp
;

public:

' (traplistbuilder) DUP

:NONAME
(hex) 7400 + CS, \ moveq.l #sel,d2
(hex) 4E4F CS, \ trap #15
(hex) systrapFlpDispatch CS,
[ SWAP LITERAL ] SWAP ; IMMEDIATE

0 SWAP ROT \ tlb 0 trp tlb

EXECUTE FlpBase10Info
( dr a-addr a-addr a-addr -- n )
r[ >abs 2>R >abs 2>R >abs
2>r4>r
[ EXECUTE ]
d0.l DROP ]r
;

EXECUTE FlpFToA
( dr c-addr -- n ) \ gives a zstring
r[ >abs 2>r4>r
[ EXECUTE ]
d0.l DROP ]r
;

EXECUTE FlpAToF
( c-addr u -- dr ) \ no err flag, just 0!
DUP atof-buf SWAP CHARS +
0 SWAP C! atof-buf SWAP MOVE
r[ atof-buf >abs 2>R
dfresult >abs 2>R
[ EXECUTE ]
@dfresult ]r
;

EXECUTE FlpCorrectedAdd
( dr dr n -- dr )
r[ >R 4>r4>r
dfresult >abs 2>R
[ EXECUTE ]
@dfresult ]r
;

EXECUTE FlpCorrectedSub
( dr dr n -- dr )
r[ >R 4>r4>r
dfresult >abs 2>R
[ EXECUTE ]
@dfresult ]r
;

EXECUTE FlpVersion
( -- ud )
[ EXECUTE ]
d0.l
;

NIP NIP DUP

:NONAME
(hex) 7400 + CS, \ moveq.l #sel,d2
(hex) 4E4F CS, \ trap #15
(hex) A306 CS, \ dc FloatDispatchEm
[ SWAP LITERAL ] SWAP ; IMMEDIATE

0 SWAP ROT

EXECUTE flpem0
( d -- d )
r[ 2>R
[ EXECUTE ]
d0.l ]r
;

EXECUTE _fp_get_fpscr
(  -- d )
[ EXECUTE ]
d0.l
;

EXECUTE _fp_set_fpscr
( d --  )
r[ 2>R
[ EXECUTE ]
]r
;

EXECUTE _f_utof
( ud -- sr)
r[ 2>R
[ EXECUTE ]
d0.l ]r
;

EXECUTE D>SF
( d -- sr )
r[ 2>R
[ EXECUTE ]
d0.l ]r
;

EXECUTE _f_ulltof
( udd -- sr )
r[ 4>R
[ EXECUTE ]
d0.l ]r
;

EXECUTE _f_lltof
( dd -- sr )
r[ 4>R
[ EXECUTE ]
d0.l ]r
;

EXECUTE _d_utod
( ud -- dr )
r[ 2>R
dfresult >abs 2>R
[ EXECUTE ]
@dfresult ]r
;

EXECUTE D>DF
( d -- dr)
r[ 2>R
dfresult >abs 2>R
[ EXECUTE ]
@dfresult ]r
;

include NewFloatMgr.2

DROP DROP DROP

: (fpcheck) _fp_get_fpscr DROP
0. _fp_set_fpscr
DUP flpInvalid AND IF
  -46 THROW THEN
DUP flpOverflow AND IF
  -43 THROW THEN
DUP flpDivByZero AND IF
  -42 THROW THEN
flpUnderflow AND IF
  -54 THROW THEN
\ DUP flpInexact AND IF
\  -41 THROW THEN
;

: DF! >R F>SF SF>DF R> DF!DF ;

: DF@
DF@DF DF>SF (fpcheck) SF>F ;

: DFABS ( dr -- dr ) (hex) 7FFF AND ;

: DFMAX ( dr dr -- dr )
DFOVER DFOVER _d_cmp DROP
DUP flpUnordered = IF
-46 THROW THEN
flpLess = IF DFSWAP THEN
DFDROP ;

: DFMIN ( dr dr -- dr )
DFOVER DFOVER _d_cmp DROP
DUP flpUnordered = IF
-46 THROW THEN
flpGreater = IF DFSWAP THEN
DFDROP ;

: SFABS ( sr -- sr ) (hex) 7FFF AND ;

: SFMAX ( sr sr -- sr )
SFOVER SFOVER _f_cmp DROP
DUP flpUnordered = IF
-46 THROW THEN
flpLess = IF SFSWAP THEN
SFDROP ;

: SFMIN ( sr sr -- sr )
SFOVER SFOVER _f_cmp DROP
DUP flpUnordered = IF
-46 THROW THEN
flpGreater = IF SFSWAP THEN
SFDROP ;

private:

: z>s  >r dup >abs StrLen r> min ;

public:

: (DFS.) atof-buf FlpFToA
  IF -46 THROW THEN
  atof-buf 32 z>s ;

: DFS.  (DFS.) type ;

: (SFS.) SF>DF (DFS.) ;
: SFS. (SFS.) type ;

: (dfloat) parse-word FlpAToF
  STATE @ IF POSTPONE DFLITERAL
  THEN
; IMMEDIATE

: (sfloat) parse-word FlpAToF
  0. _fp_set_fpscr DF>SF (fpcheck)
  STATE @ IF POSTPONE SFLITERAL
  THEN
; IMMEDIATE

end-module
